- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.FileMatcher (
import qualified Data.Set as S
import Control.Monad.Writer
-type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex)
+type GetFileMatcher = OsPath -> Annex (FileMatcher Annex)
-checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool
+checkFileMatcher :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool
checkFileMatcher lu getmatcher file =
checkFileMatcher' lu getmatcher file (return True)
-- | Allows running an action when no matcher is configured for the file.
-checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool
+checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> OsPath -> Annex Bool -> Annex Bool
checkFileMatcher' lu getmatcher file notconfigured = do
matcher <- getmatcher file
checkMatcher matcher Nothing afile lu S.empty notconfigured d
fromMaybe mempty descmsg <> UnquotedString s
return False
-fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo
+fileMatchInfo :: OsPath -> Maybe Key -> Annex MatchInfo
fileMatchInfo file mkey = do
matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
return $ MatchingFile FileInfo
tokenizeMatcher :: String -> [String]
tokenizeMatcher = filter (not . null) . concatMap splitparens . words
where
- splitparens = segmentDelim (`elem` "()")
+ splitparens = segmentDelim (`elem` ("()" :: String))
commonTokens :: LimitBy -> [ParseToken (MatchFiles Annex)]
commonTokens lb =
, ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd))
] ++ commonTokens LimitAnnexFiles
where
- preferreddir = maybe "public" fromProposedAccepted $
+ preferreddir = toOsPath $ maybe "public" fromProposedAccepted $
M.lookup preferreddirField =<< (`M.lookup` configMap pcd) =<< repoUUID pcd
preferredContentParser :: [ParseToken (MatchFiles Annex)] -> String -> [ParseResult (MatchFiles Annex)]
data LockDownConfig = LockDownConfig
{ lockingFile :: Bool
-- ^ write bit removed during lock down
- , hardlinkFileTmpDir :: Maybe RawFilePath
+ , hardlinkFileTmpDir :: Maybe OsPath
-- ^ hard link to temp directory
, checkWritePerms :: Bool
-- ^ check that write perms are successfully removed
- Lockdown can fail if a file gets deleted, or if it's unable to remove
- write permissions, and Nothing will be returned.
-}
-lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown)
+lockDown :: LockDownConfig-> OsPath -> Annex (Maybe LockedDown)
lockDown cfg file = either
(\e -> warning (UnquotedString (show e)) >> return Nothing)
(return . Just)
=<< lockDown' cfg file
-lockDown' :: LockDownConfig -> FilePath -> Annex (Either SomeException LockedDown)
+lockDown' :: LockDownConfig -> OsPath -> Annex (Either SomeException LockedDown)
lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
( nohardlink
, case hardlinkFileTmpDir cfg of
Just tmpdir -> withhardlink tmpdir
)
where
- file' = toRawFilePath file
-
nohardlink = do
setperms
withTSDelta $ liftIO . nohardlink'
nohardlink' delta = do
- cache <- genInodeCache file' delta
+ cache <- genInodeCache file delta
return $ LockedDown cfg $ KeySource
- { keyFilename = file'
- , contentLocation = file'
+ { keyFilename = file
+ , contentLocation = file
, inodeCache = cache
}
withhardlink tmpdir = do
setperms
withTSDelta $ \delta -> liftIO $ do
- (tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
- relatedTemplate $ toRawFilePath $
- "ingest-" ++ takeFileName file
+ (tmpfile, h) <- openTmpFileIn tmpdir $
+ relatedTemplate $ fromOsPath $
+ literalOsPath "ingest-" <> takeFileName file
hClose h
- let tmpfile' = fromOsPath tmpfile
- removeWhenExistsWith R.removeLink tmpfile'
- withhardlink' delta tmpfile'
+ removeWhenExistsWith R.removeLink (fromOsPath tmpfile)
+ withhardlink' delta tmpfile
`catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do
- R.createLink file' tmpfile
+ R.createLink (fromOsPath file) (fromOsPath tmpfile)
cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource
- { keyFilename = file'
+ { keyFilename = file
, contentLocation = tmpfile
, inodeCache = cache
}
setperms = when (lockingFile cfg) $ do
- freezeContent file'
+ freezeContent file
when (checkWritePerms cfg) $ do
qp <- coreQuotePath <$> Annex.getGitConfig
maybe noop (giveup . decodeBS . quote qp)
- =<< checkLockedDownWritePerms file' file'
+ =<< checkLockedDownWritePerms file file
-checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe StringContainingQuotedPath)
+checkLockedDownWritePerms :: OsPath -> OsPath -> Annex (Maybe StringContainingQuotedPath)
checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case
Just False -> Just $ "Unable to remove all write permissions from "
<> QuotedPath displayfile
then addSymlink f k mic
else do
mode <- liftIO $ catchMaybeIO $
- fileMode <$> R.getFileStatus (contentLocation source)
+ fileMode <$> R.getFileStatus
+ (fromOsPath (contentLocation source))
stagePointerFile f mode =<< hashPointerFile k
return (Just k)
fst <$> genKey source meterupdate backend
Just k -> return k
let src = contentLocation source
- ms <- liftIO $ catchMaybeIO $ R.getFileStatus src
+ ms <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath src)
mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms
case (mcache, inodeCache source) of
(_, Nothing) -> go k mcache
cleanCruft :: KeySource -> Annex ()
cleanCruft source = when (contentLocation source /= keyFilename source) $
- liftIO $ removeWhenExistsWith R.removeLink $ contentLocation source
+ liftIO $ removeWhenExistsWith removeFile $ contentLocation source
-- If a worktree file was was hard linked to an annex object before,
-- modifying the file would have caused the object to have the wrong
-- content. Clean up from that.
-cleanOldKeys :: RawFilePath -> Key -> Annex ()
+cleanOldKeys :: OsPath -> Key -> Annex ()
cleanOldKeys file newkey = do
g <- Annex.gitRepo
topf <- inRepo (toTopFilePath file)
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
-restoreFile :: RawFilePath -> Key -> SomeException -> Annex a
+restoreFile :: OsPath -> Key -> SomeException -> Annex a
restoreFile file key e = do
whenM (inAnnex key) $ do
- liftIO $ removeWhenExistsWith R.removeLink file
+ liftIO $ removeWhenExistsWith removeFile file
-- The key could be used by other files too, so leave the
-- content in the annex, and make a copy back to the file.
- obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
- unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $
- warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj)
+ obj <- calcRepo (gitAnnexLocation key)
+ unlessM (liftIO $ copyFileExternal CopyTimeStamps obj file) $
+ warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath obj
thawContent file
throwM e
{- Creates the symlink to the annexed content, returns the link target. -}
-makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
+makeLink :: OsPath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
- l <- calcRepo $ gitAnnexLink file key
+ l <- fromOsPath <$> calcRepo (gitAnnexLink file key)
replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
case mcache of
- Just c -> liftIO $ touch file (inodeCacheToMtime c) False
+ Just c -> liftIO $
+ touch (fromOsPath file) (inodeCacheToMtime c) False
Nothing -> noop
return l
{- Creates the symlink to the annexed content, and stages it in git. -}
-addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()
+addSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex ()
addSymlink file key mcache = stageSymlink file =<< genSymlink file key mcache
-genSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex Git.Sha
+genSymlink :: OsPath -> Key -> Maybe InodeCache -> Annex Git.Sha
genSymlink file key mcache = do
linktarget <- makeLink file key mcache
hashSymlink linktarget
-
- When the content of the key is not accepted into the annex, returns False.
-}
-addAnnexedFile :: AddUnlockedMatcher -> RawFilePath -> Key -> Maybe RawFilePath -> Annex Bool
+addAnnexedFile :: AddUnlockedMatcher -> OsPath -> Key -> Maybe OsPath -> Annex Bool
addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi (isJust mtmp))
( do
mode <- maybe
(pure Nothing)
- (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus tmp)
+ (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (fromOsPath tmp))
mtmp
stagePointerFile file mode =<< hashPointerFile key
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
{- Use with actions that add an already existing annex symlink or pointer
- file. The warning avoids a confusing situation where the file got copied
- from another git-annex repo, probably by accident. -}
-addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a
+addingExistingLink :: OsPath -> Key -> Annex a -> Annex a
addingExistingLink f k a = do
unlessM (isKnownKey k <||> inAnnex k) $ do
islink <- isJust <$> isAnnexLink f
{- NumCopies and MinCopies value for a file, from any configuration source,
- including .gitattributes. -}
-getFileNumMinCopies :: RawFilePath -> Annex (NumCopies, MinCopies)
+getFileNumMinCopies :: OsPath -> Annex (NumCopies, MinCopies)
getFileNumMinCopies f = do
fnumc <- getForcedNumCopies
fminc <- getForcedMinCopies
Database.Keys.getAssociatedFilesIncluding afile k
>>= getSafestNumMinCopies' afile k
-getSafestNumMinCopies' :: AssociatedFile -> Key -> [RawFilePath] -> Annex (NumCopies, MinCopies)
+getSafestNumMinCopies' :: AssociatedFile -> Key -> [OsPath] -> Annex (NumCopies, MinCopies)
getSafestNumMinCopies' afile k fs = do
l <- mapM getFileNumMinCopies fs
let l' = zip l fs
{- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line
- options. -}
-getGlobalFileNumCopies :: RawFilePath -> Annex NumCopies
+getGlobalFileNumCopies :: OsPath -> Annex NumCopies
getGlobalFileNumCopies f = fromSourcesOr defaultNumCopies
[ fst <$> getNumMinCopiesAttr f
, getGlobalNumCopies
]
-getNumMinCopiesAttr :: RawFilePath -> Annex (Maybe NumCopies, Maybe MinCopies)
+getNumMinCopiesAttr :: OsPath -> Annex (Maybe NumCopies, Maybe MinCopies)
getNumMinCopiesAttr file =
checkAttrs ["annex.numcopies", "annex.mincopies"] file >>= \case
(n:m:[]) -> return
- This is good enough for everything except dropping the file, which
- requires active verification of the copies.
-}
-numCopiesCheck :: RawFilePath -> Key -> (Int -> Int -> v) -> Annex v
+numCopiesCheck :: OsPath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do
have <- trustExclude UnTrusted =<< Remote.keyLocations key
numCopiesCheck' file vs have
-numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v
+numCopiesCheck' :: OsPath -> (Int -> Int -> v) -> [UUID] -> Annex v
numCopiesCheck' file vs have = do
needed <- fst <$> getFileNumMinCopies file
let nhave = numCopiesCount have
import Control.Concurrent.Async
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import qualified System.FilePath.ByteString as P
import qualified Data.Map as M
import qualified Data.Set as S
#ifndef mingw32_HOST_OS
-- independently. Also, this key is not getting added into the
-- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
- withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
- a (toRawFilePath tmpdir P.</> keyFile k)
+ withTmpDirIn othertmpdir (literalOsPath "proxy") $ \tmpdir ->
+ a (tmpdir </> keyFile k)
proxyput af k = do
liftIO $ sendmessage $ PUT_FROM (Offset 0)
-- the client, to avoid bad content
-- being stored in the special remote.
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
- h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode
- let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)
+ h <- liftIO $ F.openFile tmpfile WriteMode
+ let nuketmp = liftIO $ removeWhenExistsWith removeFile tmpfile
gotall <- liftIO $ receivetofile iv h len
liftIO $ hClose h
verified <- if gotall
then fst <$> finishVerifyKeyContentIncrementally' True iv
else pure False
- let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case
+ let store = tryNonAsync (storeput k af tmpfile) >>= \case
Right () -> liftIO $ sendmessage SUCCESS
Left err -> liftIO $ propagateerror err
if protoversion > ProtocolVersion 1
storetofile iv h (n - fromIntegral (B.length b)) bs
proxyget offset af k = withproxytmpfile k $ \tmpfile -> do
- let retrieve = tryNonAsync $ Remote.retrieveKeyFile r k af
- (fromRawFilePath tmpfile) nullMeterUpdate vc
+ let retrieve = tryNonAsync $ Remote.retrieveKeyFile
+ r k af tmpfile nullMeterUpdate vc
#ifndef mingw32_HOST_OS
ordered <- Remote.retrieveKeyFileInOrder r
#else
sendlen offset size
waitforfile
x <- tryNonAsync $ do
- h <- openFileBeingWritten f
+ h <- openFileBeingWritten (fromOsPath f)
hSeek h AbsoluteSeek offset
senddata' h (getcontents size)
case x of
senddata (Offset offset) f = do
size <- fromIntegral <$> getFileSize f
sendlen offset size
- withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
+ F.withBinaryFile f ReadMode $ \h -> do
hSeek h AbsoluteSeek offset
senddata' h L.hGetContents
import Utility.Glob
import Types.Command
import CmdLine.Action
-import qualified Utility.RawFilePath as R
+import qualified Utility.OsString as OS
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async
import "mtl" Control.Monad.Writer
- evaluate this function with the view parameter and reuse
- the result. The globs in the view will then be compiled and memoized.
-}
-viewedFiles :: View -> MkViewedFile -> FilePath -> MetaData -> [ViewedFile]
+viewedFiles :: View -> MkViewedFile -> OsPath -> MetaData -> [ViewedFile]
viewedFiles view =
let matchers = map viewComponentMatcher (viewComponents view)
in \mkviewedfile file metadata ->
then []
else
let paths = pathProduct $
- map (map toviewpath) (visible matches)
+ map (map (toOsPath . toviewpath))
+ (visible matches)
in if null paths
then [mkviewedfile file]
else map (</> mkviewedfile file) paths
prop_viewPath_roundtrips :: MetaValue -> Bool
prop_viewPath_roundtrips v = fromViewPath (toViewPath v) == v
-pathProduct :: [[FilePath]] -> [FilePath]
+pathProduct :: [[OsPath]] -> [OsPath]
pathProduct [] = []
pathProduct (l:ls) = foldl combinel l ls
where
filter (not . isviewunset) (zip visible values)
visible = filter viewVisible (viewComponents view)
paths = splitDirectories (dropFileName f)
- values = map (S.singleton . fromViewPath) paths
+ values = map (S.singleton . fromViewPath . fromOsPath) paths
MetaData derived = getViewedFileMetaData f
convfield (vc, v) = (viewField vc, v)
prop_view_roundtrips :: AssociatedFile -> MetaData -> Bool -> Bool
prop_view_roundtrips (AssociatedFile Nothing) _ _ = True
prop_view_roundtrips (AssociatedFile (Just f)) metadata visible = or
- [ B.null (P.takeFileName f) && B.null (P.takeDirectory f)
+ [ OS.null (takeFileName f) && OS.null (takeDirectory f)
, viewTooLarge view
- , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) (fromRawFilePath f) metadata)
+ , all hasfields (viewedFiles view (viewedFileFromReference' Nothing Nothing) f metadata)
]
where
view = View (Git.Ref "foo") $
- Note that this may generate MetaFields that legalField rejects.
- This is necessary to have a 1:1 mapping between directory names and
- fields. So this MetaData cannot safely be serialized. -}
-getDirMetaData :: FilePath -> MetaData
+getDirMetaData :: OsPath -> MetaData
getDirMetaData d = MetaData $ M.fromList $ zip fields values
where
dirs = splitDirectories d
- fields = map (mkMetaFieldUnchecked . T.pack . addTrailingPathSeparator . joinPath)
+ fields = map (mkMetaFieldUnchecked . T.pack . fromOsPath . addTrailingPathSeparator . joinPath)
(inits dirs)
values = map (S.singleton . toMetaValue . encodeBS . fromMaybe "" . headMaybe)
- (tails dirs)
+ (tails (map fromOsPath dirs))
-getWorkTreeMetaData :: FilePath -> MetaData
+getWorkTreeMetaData :: OsPath -> MetaData
getWorkTreeMetaData = getDirMetaData . dropFileName
-getViewedFileMetaData :: FilePath -> MetaData
+getViewedFileMetaData :: OsPath -> MetaData
getViewedFileMetaData = getDirMetaData . dirFromViewedFile . takeFileName
{- Applies a view to the currently checked out branch, generating a new
- Look up the metadata of annexed files, and generate any ViewedFiles,
- and stage them.
-}
-applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
+applyView' :: MkViewedFile -> (OsPath -> MetaData) -> View -> Maybe Adjustment -> Annex Git.Branch
applyView' mkviewedfile getfilemetadata view madj = do
top <- fromRepo Git.repoPath
(l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top]
applyView''
:: MkViewedFile
- -> (FilePath -> MetaData)
+ -> (OsPath -> MetaData)
-> View
-> Maybe Adjustment
-> [t]
-- Git.UpdateIndex.streamUpdateIndex'
-- here would race with process's calls
-- to it.
- | "." `B.isPrefixOf` getTopFilePath topf ->
- feed "dummy"
+ | literalOsPath "." `OS.isPrefixOf` getTopFilePath topf ->
+ feed (literalOsPath "dummy")
| otherwise -> noop
getmetadata gc mdfeeder mdcloser ts
process uh mdreader = liftIO mdreader >>= \case
Just ((topf, _, mtreeitemtype, Just k), mdlog) -> do
let metadata = maybe emptyMetaData parseCurrentMetaData mdlog
- let f = fromRawFilePath $ getTopFilePath topf
+ let f = getTopFilePath topf
let metadata' = getfilemetadata f `unionMetaData` metadata
forM_ (genviewedfiles f metadata') $ \fv -> do
- f' <- fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv)
+ f' <- fromRepo (fromTopFilePath $ asTopFilePath fv)
stagefile uh f' k mtreeitemtype
process uh mdreader
Just ((topf, sha, Just treeitemtype, Nothing), _) -> do
_ -> stagesymlink uh f k
stagesymlink uh f k = do
- linktarget <- calcRepo (gitAnnexLink f k)
+ linktarget <- fromOsPath <$> calcRepo (gitAnnexLink f k)
sha <- hashSymlink linktarget
liftIO . Git.UpdateIndex.streamUpdateIndex' uh
=<< inRepo (Git.UpdateIndex.stageSymlink f sha)
=<< catKey (DiffTree.dstsha item)
| otherwise = noop
handlechange item a = maybe noop
- (void . commandAction . a (fromRawFilePath $ getTopFilePath $ DiffTree.file item))
+ (void . commandAction . a (getTopFilePath $ DiffTree.file item))
{- Runs an action using the view index file.
- Note that the file does not necessarily exist, or can contain
withNewViewIndex :: Annex a -> Annex a
withNewViewIndex a = do
- liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexViewIndex
+ liftIO . removeWhenExistsWith removeFile
+ =<< fromRepo gitAnnexViewIndex
withViewIndex a
{- Generates a branch for a view, using the view index file
import qualified Data.ByteString as S
-type FileName = String
-type ViewedFile = FileName
+type ViewedFile = OsPath
type MkViewedFile = OsPath -> ViewedFile
(annexMaxExtensions g)
viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile
-viewedFileFromReference' maxextlen maxextensions f = concat $
+viewedFileFromReference' maxextlen maxextensions f = toOsPath $ concat $
[ escape (fromOsPath base')
, if null dirs
then ""
{- For use when operating already within a view, so whatever filepath
- is present in the work tree is already a ViewedFile. -}
viewedFileReuse :: MkViewedFile
-viewedFileReuse = fromOsPath . takeFileName
+viewedFileReuse = takeFileName
{- Extracts from a ViewedFile the directory where the file is located on
- in the reference branch. -}
-dirFromViewedFile :: ViewedFile -> FilePath
-dirFromViewedFile = fromOsPath . joinPath . map toOsPath . drop 1 . sep [] ""
+dirFromViewedFile :: ViewedFile -> OsPath
+dirFromViewedFile = joinPath . map toOsPath . drop 1 . sep [] "" . fromOsPath
where
sep l _ [] = reverse l
sep l curr (c:cs)
-- Relative filenames wanted, not directories.
| OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True
| isAbsolute (toOsPath f) || isDrive (toOsPath f) = True
- | otherwise = fromOsPath dir == dirFromViewedFile
+ | otherwise = dir == dirFromViewedFile
(viewedFileFromReference' Nothing Nothing (toOsPath f))
where
f = fromTestableFilePath tf
module Assistant.Types.Changes where
+import Common
import Types.KeySource
import Types.Key
import Utility.TList
-import Utility.FileSystemEncoding
import Annex.Ingest
import Control.Concurrent.STM
changeFile :: Change -> FilePath
changeFile (Change _ f _) = f
changeFile (PendingAddChange _ f) = f
-changeFile (InProcessAddChange _ ld) = fromRawFilePath $ keyFilename $ keySource ld
+changeFile (InProcessAddChange _ ld) = fromOsPath $ keyFilename $ keySource ld
isPendingAddChange :: Change -> Bool
isPendingAddChange (PendingAddChange {}) = True
-- to handle them.
--
-- File matching options are checked, and non-matching files skipped.
-batchFiles :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex ()
+batchFiles :: BatchFormat -> ((SeekInput, OsPath) -> CommandStart) -> Annex ()
batchFiles fmt a = batchFilesKeys fmt $ \(si, v) -> case v of
Right f -> a (si, f)
Left _k -> return Nothing
-batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key RawFilePath) -> CommandStart) -> Annex ()
+batchFilesKeys :: BatchFormat -> ((SeekInput, Either Key OsPath) -> CommandStart) -> Annex ()
batchFilesKeys fmt a = do
matcher <- getMatcher
go $ \si v -> case v of
-- CmdLine.Seek uses git ls-files.
BatchFormat _ (BatchKeys False) ->
Right . Right
- <$$> liftIO . relPathCwdToFile . toRawFilePath
+ <$$> liftIO . relPathCwdToFile . toOsPath
BatchFormat _ (BatchKeys True) -> \i ->
pure $ case deserializeKey i of
Just k -> Right (Left k)
import qualified Utility.RawFilePath as R
import Utility.Tuple
import Utility.HumanTime
+import qualified Utility.OsString as OS
import Control.Concurrent.Async
import Control.Concurrent.STM
import Data.IORef
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
-import qualified System.FilePath.ByteString as P
-import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker
- { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
+ { startAction :: Maybe KeySha -> SeekInput -> OsPath -> Key -> CommandStart
, checkContentPresent :: Maybe Bool
, usesLocationLog :: Bool
}
getfiles c [] = return (reverse c, pure True)
getfiles c (p:ps) = do
os <- seekOptions ww
- (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p]
+ (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toOsPath p]
r <- case fs of
[f] -> do
propagateLsFilesError cleanup
return (r, pure True)
withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop
-withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesNotInGit (CheckGitIgnore ci) ww a l = do
force <- Annex.getRead Annex.force
let include_ignored = force || not ci
seekFiltered (const (pure True)) a $
seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l
-withPathContents :: ((RawFilePath, RawFilePath) -> CommandSeek) -> CmdParams -> CommandSeek
+withPathContents :: ((OsPath, OsPath) -> CommandSeek) -> CmdParams -> CommandSeek
withPathContents a params = do
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
- go matcher checktimelimit params []
+ go matcher checktimelimit (map toOsPath params) []
where
go _ _ [] [] = return ()
go matcher checktimelimit (p:ps) [] =
-- fail if the path that the user provided is a broken symlink,
-- the same as it fails if the path that the user provided does not
-- exist.
- get p = ifM (isDirectory <$> R.getFileStatus p')
+ get p = ifM (isDirectory <$> R.getFileStatus (fromOsPath p))
( map (\f ->
- (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
- <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
- , return [(p', P.takeFileName p')]
+ (f, makeRelative (takeDirectory (dropTrailingPathSeparator p)) f))
+ <$> dirContentsRecursiveSkipping (literalOsPath ".git" `OS.isSuffixOf`) False p
+ , return [(p, takeFileName p)]
)
- where
- p' = toRawFilePath p
checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo
{ contentFile = f
pairs c (x:y:xs) = pairs ((x,y):c) xs
pairs _ _ = giveup "expected pairs"
-withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $
seekHelper id ww (const LsFiles.stagedNotDeleted) l
{- unlocked pointer files that are staged, and whose content has not been
- modified-}
-withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withUnmodifiedUnlockedPointers ww a l =
seekFiltered (isUnmodifiedUnlocked . snd) a $
seekHelper id ww (const LsFiles.typeChangedStaged) l
-isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
+isUnmodifiedUnlocked :: OsPath -> Annex Bool
isUnmodifiedUnlocked f = catKeyFile f >>= \case
Nothing -> return False
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
{- Finds files that may be modified. -}
-withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, OsPath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $
seekHelper id ww LsFiles.modified params
forM_ ts $ \(t, i) ->
keyaction Nothing (SeekInput [], transferKey t, mkActionItem (t, i))
-seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex ()
+seekFiltered :: ((SeekInput, OsPath) -> Annex Bool) -> ((SeekInput, OsPath) -> CommandSeek) -> Annex ([(SeekInput, OsPath)], IO Bool) -> Annex ()
seekFiltered prefilter a listfs = do
matcher <- Limit.getMatcher
checktimelimit <- mkCheckTimeLimit
-- because of the way data is streamed through git cat-file.
--
-- It can also precache location logs using the same efficient streaming.
-seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex ()
+seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (OsPath, Git.Sha, FileMode))], IO Bool) -> Annex ()
seekFilteredKeys seeker listfs = do
g <- Annex.gitRepo
mi <- MatcherInfo
-- Check if files exist, because a deleted file will still be
-- listed by ls-tree, but should not be processed.
- exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
+ exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath p))
mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case
Just ((si, f), Just (sha, size, _type))
null <$> Annex.Branch.getUnmergedRefs
| otherwise = pure False
-seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool)
+seekHelper :: (a -> OsPath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [OsPath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool)
seekHelper c ww a (WorkTreeItems l) = do
os <- seekOptions ww
v <- liftIO $ newIORef []
r <- inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l)
- (runSegmentPaths' mk c (\fs -> go v os fs g) . map toRawFilePath)
+ (runSegmentPaths' mk c (\fs -> go v os fs g) . map toOsPath)
return (r, cleanupall v)
where
- mk (Just i) f = (SeekInput [fromRawFilePath i], f)
+ mk (Just i) f = (SeekInput [fromOsPath i], f)
-- This is not accurate, but it only happens when there are a
-- great many input WorkTreeItems.
- mk Nothing f = (SeekInput [fromRawFilePath (c f)], f)
+ mk Nothing f = (SeekInput [fromOsPath (c f)], f)
go v os fs g = do
(ls, cleanup) <- a os fs g
currbranch <- getCurrentBranch
stopattop <- prepviasymlink
ps' <- flip filterM ps $ \p -> do
- let p' = toRawFilePath p
+ let p' = toOsPath p
relf <- liftIO $ relPathCwdToFile p'
ifM (not <$> (exists p' <||> hidden currbranch relf))
( prob action FileNotFound p' "not found"
then return NoWorkTreeItems
else return (WorkTreeItems ps')
- exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
+ exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus $ fromOsPath p)
prepviasymlink = do
repotopst <- inRepo $
maybe
(pure Nothing)
- (catchMaybeIO . R.getSymbolicLinkStatus)
+ (catchMaybeIO . R.getSymbolicLinkStatus . fromOsPath)
. Git.repoWorkTree
return $ \st -> case repotopst of
Nothing -> False
viasymlink _ Nothing = return False
viasymlink stopattop (Just p) = do
- st <- liftIO $ R.getSymbolicLinkStatus p
+ st <- liftIO $ R.getSymbolicLinkStatus $ fromOsPath p
if stopattop st
then return False
else if isSymbolicLink st
| otherwise = return False
prob action errorid p msg = do
- toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p])
+ toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromOsPath p])
Annex.incError
return False
-notSymlink :: RawFilePath -> IO Bool
-notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus f
+notSymlink :: OsPath -> IO Bool
+notSymlink f = liftIO $ not . isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f)
{- Returns an action that, when there's a time limit, can be used
- to check it before processing a file. The first action is run when
import Data.Time.Clock.POSIX
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (accessTime, isSymbolicLink)
{- Some limits can look at the current status of files on
matchGlobFile glob = go
where
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
- go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi))
+ go (MatchingFile fi) = pure $ matchGlob cglob (fromOsPath (matchFile fi))
go (MatchingInfo p) = pure $ case providedFilePath p of
- Just f -> matchGlob cglob (fromRawFilePath f)
+ Just f -> matchGlob cglob (fromOsPath f)
Nothing -> False
- go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p)
+ go (MatchingUserInfo p) = matchGlob cglob . fromOsPath
+ <$> getUserInfo (userProvidedFilePath p)
{- Add a limit to skip files when there is no other file using the same
- content, with a name matching the glob. -}
Just f -> check k f
Nothing -> return False
go (MatchingUserInfo p) k =
- check k . toRawFilePath
- =<< getUserInfo (userProvidedFilePath p)
+ check k =<< getUserInfo (userProvidedFilePath p)
cglob = compileGlob glob CaseSensitive (GlobFilePath True) -- memoized
- matchesglob f = matchGlob cglob (fromRawFilePath f)
+ matchesglob f = matchGlob cglob (fromOsPath f)
#ifdef mingw32_HOST_OS
- || matchGlob cglob (fromRawFilePath (toInternalGitPath f))
+ || matchGlob cglob (fromOsPath (toInternalGitPath f))
#endif
check k skipf = do
-- Find other files with the same content, with filenames
-- matching the glob.
g <- Annex.gitRepo
- fs <- filter (/= P.normalise skipf)
+ fs <- filter (/= normalise skipf)
. filter matchesglob
- . map (\f -> P.normalise (fromTopFilePath f g))
+ . map (\f -> normalise (fromTopFilePath f g))
<$> Database.Keys.getAssociatedFiles k
-- Some associated files in the keys database may no longer
-- correspond to files in the repository. This is checked
addMagicLimit
:: String
- -> (Magic -> FilePath -> Annex (Maybe String))
+ -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String)
-> String
magic <- liftIO initMagicMime
addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob
where
- querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case
+ querymagic' magic f = liftIO (isPointerFile f) >>= \case
-- Avoid getting magic of a pointer file, which would
-- wrongly be detected as text.
Just _ -> return Nothing
-- When the file is an annex symlink, get magic of the
-- object file.
- Nothing -> isAnnexLink (toRawFilePath f) >>= \case
- Just k -> withObjectLoc k $
- querymagic magic . fromRawFilePath
+ Nothing -> isAnnexLink f >>= \case
+ Just k -> withObjectLoc k (querymagic magic)
Nothing -> querymagic magic f
matchMagic
:: String
- -> (Magic -> FilePath -> Annex (Maybe String))
+ -> (Magic -> OsPath -> Annex (Maybe String))
-> (ProvidedInfo -> Maybe String)
-> (UserProvidedInfo -> UserInfo String)
-> Maybe Magic
cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized
go (MatchingFile fi) = catchBoolIO $
maybe False (matchGlob cglob)
- <$> querymagic magic (fromRawFilePath (contentFile fi))
+ <$> querymagic magic (contentFile fi)
go (MatchingInfo p) = maybe
(usecontent (providedKey p))
(pure . matchGlob cglob)
go (MatchingUserInfo p) =
matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p)
usecontent (Just k) = withObjectLoc k $ \obj -> catchBoolIO $
- maybe False (matchGlob cglob)
- <$> querymagic magic (fromRawFilePath obj)
+ maybe False (matchGlob cglob) <$> querymagic magic obj
usecontent Nothing = pure False
matchMagic limitname _ _ _ Nothing _ =
Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
islocked <- isPointerFile f >>= \case
Just _key -> return False
Nothing -> isSymbolicLink
- <$> R.getSymbolicLinkStatus f
+ <$> R.getSymbolicLinkStatus (fromOsPath f)
return (islocked == wantlocked)
matchLockStatus wantlocked (MatchingInfo p) =
pure $ case providedLinkType p of
}
{- Limit to content that is in a directory, anywhere in the repository tree -}
-limitInDir :: FilePath -> String -> MatchFiles Annex
+limitInDir :: OsPath -> String -> MatchFiles Annex
limitInDir dir desc = MatchFiles
{ matchAction = const $ const go
, matchNeedsFileName = True
, matchDesc = matchDescSimple desc
}
where
- go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi
- go (MatchingInfo p) = maybe (pure False) (checkf . fromRawFilePath) (providedFilePath p)
+ go (MatchingFile fi) = checkf $ matchFile fi
+ go (MatchingInfo p) = maybe (pure False) checkf (providedFilePath p)
go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p)
checkf = return . elem dir . splitPath . takeDirectory
where
check now k = inAnnexCheck k $ \f ->
liftIO $ catchDefaultIO False $ do
- s <- R.getSymbolicLinkStatus f
+ s <- R.getSymbolicLinkStatus (fromOsPath f)
let accessed = realToFrac (accessTime s)
let delta = now - accessed
return $ delta <= secs
-- This is used when testing a matcher, with values to match against
-- provided by the user.
data UserProvidedInfo = UserProvidedInfo
- { userProvidedFilePath :: UserInfo FilePath
+ { userProvidedFilePath :: UserInfo OsPath
, userProvidedKey :: UserInfo Key
, userProvidedFileSize :: UserInfo FileSize
, userProvidedMimeType :: UserInfo MimeType
projects / git-annex.git / commitdiff